home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / sources / io.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-09-22  |  10.5 KB  |  420 lines
  1. /* Scheme In One Define.
  2.  
  3. The garbage collector, the name and other parts of this program are
  4.  
  5.  *                     COPYRIGHT (c) 1989 BY                              *
  6.  *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7.  
  8. Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. rational numbers, and other major enhancments by
  10.  
  11.  *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12.  
  13. Permission  to use, copy, modify, distribute and sell this software and its
  14. documentation  for  any purpose and without fee is hereby granted, provided
  15. that  the  above  copyright  notice appear in all copies and that both that
  16. copyright   notice   and   this  permission  notice  appear  in  supporting
  17. documentation,  and that the name of Paradigm Associates Inc not be used in
  18. advertising or publicity pertaining to distribution of the software without
  19. specific, written prior permission.
  20.  
  21. PARADIGM  DISCLAIMS  ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  22. ALL  IMPLIED  WARRANTIES  OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  23. PARADIGM  BE  LIABLE  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  24. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
  25. IN  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  26. OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  27.  
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <string.h>
  32. #include <ctype.h>
  33. #include <setjmp.h>
  34. #include <signal.h>
  35. #include <math.h>
  36. #include <limits.h>
  37.  
  38. #include "siod.h"
  39.  
  40. char *checkstr(char *s)
  41. {char *p;
  42.  p=tkbuffer;
  43.  while(*s)
  44.    {if((*s=='\\')||(*s=='"'))
  45.         *p++='\\';
  46.     *p++=*s++;}
  47.  *p='\0';
  48.  return(tkbuffer);}
  49.  
  50. int checksym(char *s)
  51. {char *p;
  52.  int flag;
  53.  p=tkbuffer;
  54.  flag=1;
  55.  while(*s)
  56.    {if(!(isdigit(*s)|| islower(*s) || strchr("!$%&*/:<=>?_-+~@.#^",*s)))
  57.       flag=0;
  58.     if((*s=='\\')||(*s=='|'))
  59.         *p++='\\';
  60.     *p++=*s++;}
  61.  *p='\0';
  62.  if(NULLP(lreadtk(0)))
  63.    flag=0;;
  64.  return(flag);}
  65.  
  66. LISP lprin1f(LISP exp,FILE *f)
  67. {LISP tmp;
  68.  int i,size;
  69.  switch TYPE(exp)
  70.    {case tc_nil:
  71.       fput_st(f,"()");
  72.       break;
  73.    case tc_environment:
  74.       fput_st(f,"#<ENVIRONMENT>");
  75.       break;
  76.    case tc_cons:
  77.       fput_st(f,"(");
  78.       lprin1f(car(exp),f);
  79.       for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
  80.     {fput_st(f," ");lprin1f(car(tmp),f);}
  81.       if NNULLP(tmp) {fput_st(f," . ");lprin1f(tmp,f);}
  82.       fput_st(f,")");
  83.       break;
  84.     case tc_flonum:
  85.       sprintf(tkbuffer,"%.16g",FLONM(exp));
  86.       fput_st(f,tkbuffer);
  87.       break;
  88.     case tc_compnum:
  89.       sprintf(tkbuffer,"%.6g%+.6gi",COMPRE(exp),COMPIM(exp));
  90.       fput_st(f,tkbuffer);
  91.       break;
  92.     case tc_ratnum:
  93.       sprintf(tkbuffer,"%d/%u",RATNUM(exp),RATDEN(exp));
  94.       fput_st(f,tkbuffer);
  95.       break;
  96.     case tc_intnum:
  97.       sprintf(tkbuffer,"%d",INTNM(exp));
  98.       fput_st(f,tkbuffer);
  99.       break;
  100.     case tc_char:
  101.       if(isprint(CHARV(exp)))
  102.         sprintf(tkbuffer,"#\\%c",CHARV(exp));
  103.       else
  104.         sprintf(tkbuffer,"#\\(%d)",(long)CHARV(exp));
  105.       fput_st(f,tkbuffer);
  106.       break;
  107.     case tc_macro:
  108.       if(checksym(PNAME(exp)))
  109.         {fput_st(f,"#<MACRO: ");
  110.          fput_st(f,tkbuffer);
  111.          fput_st(f,">");}
  112.       else
  113.         {fput_st(f,"#<MACRO: |");
  114.          fput_st(f,tkbuffer);
  115.          fput_st(f,"|>");}
  116.       break;
  117.     case tc_symbol:
  118.       if(EQ(exp,truth)||checksym(PNAME(exp)))
  119.         fput_st(f,PNAME(exp));
  120.       else
  121.         {fput_st(f,"|");
  122.          fput_st(f,tkbuffer);
  123.          fput_st(f,"|");}
  124.       break;
  125.     case tc_port:
  126.       fput_st(f,"#<PORT>");
  127.       break;
  128.     case tc_subr_0:
  129.     case tc_subr_1:
  130.     case tc_subr_2:
  131.     case tc_subr_3:
  132.     case tc_lsubr:
  133.     case tc_fsubr:
  134.     case tc_msubr:
  135.       sprintf(tkbuffer,"#<SUBR(%d) ",TYPE(exp)-4);
  136.       fput_st(f,tkbuffer);
  137.       fput_st(f,(*exp).storage_as.subr.name);
  138.       fput_st(f,">");
  139.       break;
  140.     case tc_closure:
  141.       sprintf(tkbuffer,"#<LAMBDA(%d)>",leng(car(CODE(exp))));
  142.       fput_st(f,tkbuffer);
  143.       break;
  144.     case tc_fluidclosure:
  145.       sprintf(tkbuffer,"#<FLUID-LAMBDA(%d)>",leng(car(CODE(exp))));
  146.       fput_st(f,tkbuffer);
  147.       break;
  148.     case tc_rec:
  149.       sprintf(tkbuffer,"#<NAMED-LAMBDA(%d)>",leng(car(CODE(exp)))-1);
  150.       fput_st(f,tkbuffer);
  151.       break;
  152.     case tc_vector:
  153.       fput_st(f,"#("); 
  154.       size = VECSIZE(exp);
  155.       if(size>=1)
  156.         {lprin1f(VECTOR(exp)[0],f);
  157.          for(i=1;i<size;i++)
  158.            {fput_st(f," ");
  159.             lprin1f(VECTOR(exp)[i],f);}}
  160.       fput_st(f,")");         
  161.       break;
  162.     case tc_string:
  163.       fput_st(f,"\"");
  164.       fput_st(f,checkstr(SNAME(exp)));
  165.       fput_st(f,"\"");
  166.       break;
  167.     default:
  168.       sprintf(tkbuffer,"#<UNKNOWN %d %lX>",TYPE(exp),exp);
  169.       fput_st(f,tkbuffer);}
  170.  return(NIL);}
  171.  
  172. LISP lprint(LISP exp,LISP port)
  173. {FILE *f;
  174.  if(NULLP(port))
  175.   {f = get_cur_out();
  176.    fput_st(f,"\n");
  177.    lprin1f(exp,f);
  178.    fput_st(f," ");}
  179.  else
  180.   {if(NPORTP(port)) err("print",port,ERR_SECOND | ERR_NPOR);
  181.    f = PORTPTR(port);
  182.    fput_st(f,"\n");
  183.    lprin1f(exp,f);
  184.    fput_st(f," ");}
  185.  return(NIL);}
  186.  
  187. LISP lwrite(LISP exp,LISP port)
  188. {FILE *f;
  189.  if(NULLP(port))
  190.   {f = get_cur_out();
  191.    lprin1f(exp,f);}
  192.  else
  193.   {if(NPORTP(port)) err("write",port,ERR_SECOND | ERR_NPOR);
  194.    f = PORTPTR(port);
  195.    lprin1f(exp,f);}
  196.  return(NIL);}
  197.  
  198. LISP lprin(LISP exp,LISP port)
  199. {FILE *f;
  200.  if(NULLP(port))
  201.   {f = get_cur_out();
  202.    ldisplayf(exp,f);}
  203.  else
  204.   {if(NPORTP(port)) err("display",port,ERR_SECOND | ERR_NPOR);
  205.    f = PORTPTR(port);
  206.    ldisplayf(exp,f);}
  207.  return(NIL);}
  208.  
  209. LISP lwritechar(LISP exp,LISP port)
  210. {FILE *f;
  211.  char st[4]=" ";
  212.  if(NCHARP(exp))err("write-char",exp,ERR_FIRST | ERR_NCHA);
  213.  st[0] = CHARV(exp);
  214.  if(NULLP(port))
  215.   put_st(st);
  216.  else
  217.   {if(NPORTP(port)) err("write-char",port,ERR_SECOND | ERR_NPOR);
  218.    f = PORTPTR(port);
  219.    fput_st(f,st);}
  220.  return(NIL);}
  221.  
  222. LISP writeln(LISP args)
  223. {LISP l;
  224.  FILE *f;
  225.  f = get_cur_out();
  226.  for(l=args;NNULLP(l);l=cdr(l))
  227.    ldisplayf(car(l),f);
  228.  fput_st(f,"\n");
  229.  return(NIL);}
  230.  
  231. LISP ldisplayf(LISP exp,FILE *f)
  232. {LISP tmp;
  233.  int i,size;
  234.  switch TYPE(exp)
  235.    {case tc_nil:
  236.       fput_st(f,"()");
  237.       break;
  238.    case tc_environment:
  239.       fput_st(f,"#<ENVIRONMENT>");
  240.       break;
  241.    case tc_cons:
  242.       fput_st(f,"(");
  243.       ldisplayf(car(exp),f);
  244.       for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
  245.     {fput_st(f," ");ldisplayf(car(tmp),f);}
  246.       if NNULLP(tmp) {fput_st(f," . ");ldisplayf(tmp,f);}
  247.       fput_st(f,")");
  248.       break;
  249.     case tc_flonum:
  250.       sprintf(tkbuffer,"%.16g",FLONM(exp));
  251.       fput_st(f,tkbuffer);
  252.       break;
  253.     case tc_compnum:
  254.       sprintf(tkbuffer,"%.6g%+.6gi",COMPRE(exp),COMPIM(exp));
  255.       fput_st(f,tkbuffer);
  256.       break;
  257.     case tc_ratnum:
  258.       sprintf(tkbuffer,"%d/%u",RATNUM(exp),RATDEN(exp));
  259.       fput_st(f,tkbuffer);
  260.       break;
  261.     case tc_intnum:
  262.       sprintf(tkbuffer,"%d",INTNM(exp));
  263.       fput_st(f,tkbuffer);
  264.       break;
  265.     case tc_char:
  266.       sprintf(tkbuffer,"%c",CHARV(exp));
  267.       fput_st(f,tkbuffer);
  268.       break;
  269.     case tc_macro:
  270.     case tc_symbol:
  271.       fput_st(f,PNAME(exp));
  272.       break;
  273.     case tc_port:
  274.       fput_st(f,"#<PORT>");
  275.       break;
  276.     case tc_subr_0:
  277.     case tc_subr_1:
  278.     case tc_subr_2:
  279.     case tc_subr_3:
  280.     case tc_lsubr:
  281.     case tc_fsubr:
  282.     case tc_msubr:
  283.       fput_st(f,"#<SUBR ");
  284.       fput_st(f,(*exp).storage_as.subr.name);
  285.       fput_st(f,">");
  286.       break;
  287.     case tc_closure:
  288.       fput_st(f,"#<LAMBDA>");
  289.       break;
  290.     case tc_fluidclosure:
  291.       fput_st(f,"#<FLUID-LAMBDA>");
  292.       break;
  293.     case tc_rec:
  294.       fput_st(f,"#<NAMED-LAMBDA ");
  295.       ldisplayf(car(car(CODE(exp))),f);
  296.       fput_st(f,">");
  297.       break;
  298.     case tc_vector:
  299.       fput_st(f,"#("); 
  300.       size = VECSIZE(exp);
  301.       if(size>=1)
  302.         {ldisplayf(VECTOR(exp)[0],f);
  303.          for(i=1;i<size;i++)
  304.            {fput_st(f," ");
  305.             ldisplayf(VECTOR(exp)[i],f);}}
  306.       fput_st(f,")");         
  307.       break;
  308.     case tc_string:
  309.       fput_st(f,SNAME(exp));
  310.       break;
  311.     default:
  312.       sprintf(tkbuffer,"#<UNKNOWN %d %lX>",TYPE(exp),exp);
  313.       fput_st(f,tkbuffer);}
  314.  return(NIL);}
  315.  
  316. LISP lprintlenght(LISP exp,LISP type)
  317. {LISP tmp;
  318.  int i,size,tot;
  319.  switch TYPE(exp)
  320.    {case tc_nil:
  321.       tot=2;
  322.       break;
  323.    case tc_environment:
  324.       tot=14;
  325.       break;
  326.    case tc_cons:
  327.       tot=1;
  328.       tot+=INTNM(lprintlenght(car(exp),type));
  329.       for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
  330.     {tot+=1;tot+=INTNM(lprintlenght(car(tmp),type));}
  331.       if NNULLP(tmp) {tot+=3;tot+=INTNM(lprintlenght(tmp,type));}
  332.       tot+=1;
  333.       break;
  334.     case tc_flonum:
  335.       tot=sprintf(tkbuffer,"%.16g",FLONM(exp));
  336.       break;
  337.     case tc_compnum:
  338.       tot=sprintf(tkbuffer,"%.6g%+.6gi",COMPRE(exp),COMPIM(exp));
  339.       break;
  340.     case tc_ratnum:
  341.       tot=sprintf(tkbuffer,"%d/%d",RATNUM(exp),RATDEN(exp));
  342.       break;
  343.     case tc_intnum:
  344.       tot=sprintf(tkbuffer,"%d",INTNM(exp));
  345.       break;
  346.     case tc_char:
  347.       tot=1;
  348.       break;
  349.     case tc_macro:
  350.       if(NULLP(type))
  351.         tot=strlen(PNAME(exp));
  352.       else if(checksym(PNAME(exp)))
  353.         {tot=10;
  354.          tot+=strlen(tkbuffer);}
  355.       else
  356.         {tot=12;
  357.          tot+= strlen(tkbuffer);}
  358.     case tc_symbol:
  359.       if(NULLP(type))
  360.         tot=strlen(PNAME(exp));
  361.       else if(checksym(PNAME(exp))||EQ(exp,truth))
  362.         tot=strlen(tkbuffer);
  363.       else
  364.         {tot=2;
  365.          tot+=strlen(tkbuffer);}
  366.       break;
  367.     case tc_port:
  368.       tot=7;
  369.       break;
  370.     case tc_subr_0:
  371.     case tc_subr_1:
  372.     case tc_subr_2:
  373.     case tc_subr_3:
  374.     case tc_lsubr:
  375.     case tc_fsubr:
  376.     case tc_msubr:
  377.       if(NULLP(type))
  378.         tot=8;
  379.       else
  380.         tot=11;
  381.       tot+=strlen((*exp).storage_as.subr.name);
  382.       break;
  383.     case tc_closure:
  384.       if(NULLP(type))
  385.         tot=9;
  386.       else
  387.         tot=sprintf(tkbuffer,"#<LAMBDA(%d)>",leng(car(CODE(exp))));
  388.       break;
  389.     case tc_fluidclosure:
  390.       if(NULLP(type))
  391.         tot=15;
  392.       else
  393.         tot=sprintf(tkbuffer,"#<FLUID-LAMBDA(%d)>",leng(car(CODE(exp))));
  394.       break;
  395.     case tc_rec:
  396.       if(NULLP(type))
  397.         {tot=16;
  398.          tot+=INTNM(lprintlenght(car(car(CODE(exp))),type));}
  399.       else
  400.          tot=sprintf(tkbuffer,"#<NAMED-LAMBDA(%d)>",leng(car(CODE(exp))));
  401.       break;
  402.     case tc_vector:
  403.       tot=2; 
  404.       size = VECSIZE(exp);
  405.       tot+=INTNM(lprintlenght(VECTOR(exp)[0],type));
  406.       for(i=1;i<size;i++)
  407.         {tot+=1;
  408.          tot+=INTNM(lprintlenght(VECTOR(exp)[i],type));}
  409.       tot+=1;         
  410.       break;
  411.     case tc_string:
  412.       if(NULLP(type))
  413.          tot=strlen(SNAME(exp));
  414.       else
  415.          tot=strlen(checkstr(SNAME(exp)))+2;
  416.       break;
  417.     default:
  418.       tot=sprintf(tkbuffer,"#<UNKNOWN %d %lX>",TYPE(exp),exp);}
  419.  return(intcons(tot));}
  420.